;; collection/list.scm - (c) rohan drape, 2000-2005

;; Aliases for R5RS and SRFI-1 procedures having a list- prefix.

(define ref      list-ref)
(define tail     list-tail)
(define tabulate list-tabulate)
(define copy     list-copy)
(define index    list-index)

;; [R5RS+] Return 1 for non-<list> arguments.

(define (length* l) (if (list? l) (length l) 1))

;; [SRFI-1+] Generate {i,...,j-1}.

(define (iotaR i j) (iota (- j i) i))

;; [SRFI-1+] Generate a <list> of <number>s, the first is `seed', each
;; subsequent element is derived by multiplying the previous element
;; by `factor'.  The <list> halts before exceeding `limit'.

(define (iotaG seed factor limit)
  (unfold (lambda (x) (> x limit))
	  (lambda (x) x)
	  (lambda (x) (* x factor))
	  seed))

;; [SRFI-1+] Make a <list> of `n' places, the first is `init', each
;; subsequent is the previous multiplied by `factor'.

(define (geom n init factor)
  (if (= n 0) '() (cons init (geom (- n 1) (* init factor) factor))))

;; [SRFI-1+] Variant that applies to a <list> of <list>s.

(define (zipL l) (apply zip l))

;; [SRFI-1+] Variant that deletes left duplicates.

(define (delete-duplicates-left l . =)
  (reverse (delete-duplicates (reverse l) (if (null? =) equal? =))))

;; [SRFI-1+] Return the empty <list> if `n' is not less than the length
;; of the list `l'.

(define (drop* l n) (if (> (length l) n) (drop l n) '()))

;; [SRFI-1+] Allows `element' to be a zero or one argument procedure.

(define (tabulate* n element)
  (let ((is-thunk? (thunk? element)))
    (map (lambda (index)
	   (if is-thunk?
	       (element)
	       (element index)))
	 (iota n))))

;; [SRFI-13] Extend the <list> l to `n' places with `d'.

(define (pad-right l n d)
  (let ((i (length l)))
    (cond ((= i n) l)
	  ((> i n) (take l n))
	  (else (append l (make-list (- n i) d))))))

;; [R5RS+] A true predicate form of 'member'.

(define (member? o l) (if (member o l) #t #f))

;; Return a list of `n' places.  If `l' is a list with fewer than `n'
;; elements returns the circular expansion of `l', if `l' is a list
;; with more than `n' elements returns only first `n' elements of `l',
;; if `l'is a list of `n' elements returns `l'.  If `l' is not a list
;; returns a list of `n' elements each being `l'.

(define (extend l n)
  (if (and (list? l) (not (null? l)))
      (let ((z (length l)))
	(cond ((= z n) l)
	      ((> z n) (take l n))
	      (else (extend (append l l) n))))
      (make-list n l)))

;; Extend all lists at `l' to be equal in length to the longest list
;; at `l'.  If any element is not a list it is replaced with a list of
;; itself of that length.

(define (extend-all l)
  (let ((n (apply max (map length* l))))
    (map (lambda (e) (extend e n)) l)))

;; [R5RS+] Return the element `n', modulo the length of `l', at `l'.

(define (ref/wrap l n) (ref l (modulo n (length l))))

;; Variant that wraps indices and allows non list input.

(define (at l n) (if (list? l) (ref/wrap l n) l))

;; Return the element `n' places from the end of `l'.

(define (ref-right l n)
  (ref l (- (- (length l) n) 1)))

;; Return a sub-list of `l' containing only those elements at indices
;; for which the procedure `predicate' evaluates to '#t'.

(define (filter-index predicate l)
  (map (lambda (index) (ref l index))
       (filter predicate (iota (length l)))))

;; Return a <list> containing every `n'th element of the list `l' in
;; sequence.

(define (take-cycle l n)
  (filter-index (lambda (i) (= 0 (modulo i n))) l))

;; Return a <list> of <list>s, each containing a cycle generated by
;; 'take-cycle'.

(define (cycles l n)
  (map (lambda (i)
	 (take-cycle (drop* l i) n))
       (iota n)))

;; Return a <list> that interleaves values from the <list>s at `l'.

(define (interleave . l) (apply append-map (lambda e e) l))

;; An interleave variant that extends input lists to be of equal
;; length before interleaving.  The name is courtesy SC3.

(define (lace . l) (apply append-map (lambda e e) (extend-all l)))

;; A zip variant that extends input lists to be of equal length
;; before zipping.  The name is courtesy SC3.

(define (flop . l) (apply map list (extend-all l)))

;; Remove all elements from the list `l' the indexes to which satisfy
;; predicate.

(define (remove-index p l)
  (fold-right (lambda (e i r) (if (p i) r (cons e r)))
	      '()
	      l (iota (length l))))

;; Remove at most `n' elements from the list `l' that satisfy the
;; predicate `p'.

(define (remove-count p l n)
  (if (null? l)
      '()
      (if (and (p (car l)) (> n 0))
	  (remove-count p (cdr l) (- n 1))
	  (cons (car l) (remove-count p (cdr l) n)))))

;; Delete at most `n' elements of `l' that are equal to `x' under the
;; test `p', or under 'equal?' if `p' is not given.

(define (delete-count x l n . p)
  (let ((test (if (null? p)
		  equal?
		  (car p))))
    (remove-count (lambda (e) (test x e)) l n)))

;; Return a rotation of `l' by `n' places.

(define (rotate l n)
  (let ((ll (length l)))
    (map (lambda (index) (ref l (modulo (+ n index) ll))) 
	 (iota ll))))

(define (rotate-right l n) (rotate l (- n)))

;; Derivative of the map procedure. The `proc' procedure is applied to
;; the elements of the `l' and `more' lists *preceded* by the current
;; index.

(define (map/index proc l . more)
  (apply map proc (iota (length l)) l more))

;; Derivative of the 'for-each' procedure. The `proc' procedure is
;; applied to the elements of the `l' and `more' lists *preceded* by
;; the current index.

(define (for-each/index proc l . more)
  (apply for-each proc (iota (length l)) l more))

;; Evaluates to a randomly selected element of the proper list 'l'.

(define (choose l)
  (ref l (randomI-zero-right (length l))))

;; Evaluates to a random element from the proper list `l' as if it
;; were a list distributed with the proportions at `proportions'.
;; There should be a variant that evaluates to a no argument procedure
;; for multiple invocations.

(define (choose/proportions l proportions)
  (let* ((p-sum (cdr (d->dx 0 proportions)))
	 (n (* (last p-sum) (randomN))))
    (ref l (index (lambda (e) (< n e)) p-sum))))

;; Return a random permutation of the list `l'.  This is not a
;; mutation operation.

(define (shuffle l)
  (map cdr
       (sort 
	(map (lambda (x) (cons (randomU) x)) l)
	(lambda (x y) (< (car x) (car y))))))

;; Return a list derived from the proper list `l' by placing `object'
;; in `l' before the first element for which `predicate' evaluates to
;; '#t', or at the end of the list.

(define (insert l predicate object)
  (if (null? l)
      (cons object l)
      (if (predicate (car l))
	  (cons object l)
	  (cons (car l) (insert (cdr l) predicate object)))))

;; Return #t iff for all elements of `list' the given `predicate' is
;; #t.

(define (uniform? predicate list)
  (cond ((null? list)
	 #t)
	((predicate (car list))
	 (uniform? predicate (cdr list)))
	(else
	 #f)))

;; Return the index of the first element of `l' that is equal to `x'
;; under `=', which defaults to 'equal?', or '#f' if no element is
;; equal.

(define (index-equal x l =) (index (cut = <> x) l))

;; Return a string that contains the printed representations, as given
;; by 'display', of the objects at `list', delimited by the string
;; `delimiter'.

(define (list->delimited-string list delimiter)
  (fold-right string-append 
	      "" 
	      (map (lambda (e) 
		     (format "~a" e))
		   (intersperse list delimiter))))

;; Return a list where every element at `l' is spliced into the result
;; list.  This is a non-recursive flatten operation.

(define (splice l)
  (if (null? l)
      '()
      (let ((next (car l)))
	(if (list? next)
	    (append next (splice (cdr l)))
	    (cons next (splice (cdr l)))))))

;; Variant that splices only sub-lists at `l' that satisy the
;; predicate `p'.

(define (splice-if l p)
  (if (null? l)
      '()
      (let ((next (car l)))
	(if (and (list? next) (p next))
	    (append next (splice (cdr l)))
	    (cons next (splice (cdr l)))))))

;; Set the `n'th element of the list `l' to `v'.  Return `l'.

(define (list-set! l n v) (set-car! (drop l n) v) l)

;; Return a list of objects read from `input-port' using the one
;; argument procedure `reader'.

(define (port->list reader input-port)
  (let ((next (reader input-port)))
    (if (eof-object? next)
	'()
	(cons next (port->list reader input-port)))))


;; Return a list of `n' places formed by applying `reader' `n' times
;; to `input-port'.

(define (list-read n reader input-port)
  (let loop ((result '())
	     (i 0))
    (if (= i n)
	(reverse result)
	(loop (cons (reader input-port) result) (+ i 1)))))

;; Write the objects at the list `l' to `port' by applying `writer' to
;; the each element.

(define (list-write l writer . port)
  (let ((port_ (if (null? port) (current-output-port) (car port))))
    (for-each (lambda (e) (writer e port_)) l)))

;; Return the sublist of `list' from indices `left' to `right',
;; inclusive and exclusive.

(define (sublist list left right)
  (take (drop list left) (- right left)))

;; Insert `e' between elements of `list'.  Courtesy Oleg Kiselyov.

(define (intersperse list e)
  (if (null? list) 
      list
      (let loop ((l (cdr list)) (dest (cons (car list) '())))
	(if (null? l) 
	    (reverse dest)
	    (loop (cdr l) (cons (car l) (cons e dest)))))))

(define (intersperse! list e)
  (if (null? list) 
      list
      (let loop ((l list))
	(let ((next-l (cdr l)))
	  (if (null? next-l) 
	      list
	      (begin
		(set-cdr! l (cons e next-l))
		(loop next-l)))))))

;; Return `l' as a palindrome. 

(define (mirror l) (append l (cdr (reverse l))))

;; Variant that removes the last element.  This is useful if the list
;; will be repeated cyclically.

(define (mirror1 l) (append l (cdr (reverse (cdr l)))))

;; Variant that has center element duplicated.

(define (mirror2 l) (append l (reverse l)))

;; Return a list that consists of `n' repetitions of `l'.

(define (repeat l n) (if (<= n 0) '() (append l (repeat l (- n 1)))))

;; Predicate to determine if `l' is a one element list.

(define (singleton? l) (and (list? l) (null? (cdr l))))

;; Syntax to add `item' to the start of `list'.

(define-syntax push!
  (syntax-rules ()
    ((_ item list)
     (set! list (cons item list)))))

;; Variant of for-each.

(define (iterate l p)
  (if (thunk? p)
      (integer-iterate (length l) p)
      (for-each p l)))

;; Swap elements of l at i and j.

(define (swap! l i j)
  (let ((t (ref l i)))
    (list-set! l i (ref l j))
    (list-set! l j t)))

;; Generate a function to compare to lists using the element
;; comparator `<'.  A short list will compare less than unless an
;; early element has compared greater than.

(define (make-list-comparator <)
  (lambda (a b)
    (let loop ((a* a) (b* b))
      (cond ((or (and (null? a*) (null? b*)) (null? b*))  #f)
	    ((or (null? a*) (< (car a*) (car b*))) #t)
	    (else (loop (cdr a*) (cdr b*)))))))

(define list-< (make-list-comparator <))

;; Variant that transforms `p' into a tuple variant.

(define (mapL p l) (map (as/l p) l))

;; Variant that transforms `p', `f' and `g' into tuple variants.

(define (unfoldL p f g seed)
  (unfold (as/l p) (as/l f) (as/l g) seed))

#|

;; Aliases for R5RS list operations that do not have a list prefix.

(define list-car car)
(define list-cdr cdr)
(define list-null null)
(define list-length length)
(define list-append append)
(define list-map map)
(define list-append-map append-map)
(define list-member member)
(define list-for-each for-each)
(define list-reverse reverse)

;; Aliases for SRFI-1 list operations that do not have a list prefix.

(define list-append! append!)
(define list-delete delete)
(define list-delete! delete!)
(define list-delete-duplicates delete-duplicates) 
(define list-take take)
(define list-take-right take-right)
(define list-drop drop)
(define list-drop-right drop-right)
(define list-filter filter)
(define list-zip zip)
(define list-first first)
(define list-second second)
(define list-third third)
(define list-last last)
(define list-iota iota)
(define list-find find)
(define list-find-tail find)

;; Aliases for procedures define here.

(define list-map/index map/index)
(define list-for-each/index for-each/index)
(define list-member? member?)
(define list-geom geom)
(define list-extend extend)
(define list-extend-all extend-all)
(define list-pad-right pad-right)
(define list-filter-index filter-index)
(define list-take-cycle take-cycle)
(define list-interleave interleave)
(define list-lace lace)
(define list-zipL zipL)
(define list-flop flop)
(define list-singleton? singleton?)
(define list-repeat repeat)
(define list-tabulate* tabulate*)
(define list-uniform? uniform?)
(define list-shuffle shuffle)

|#
